home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-imgrea.adb < prev    next >
Text File  |  1996-01-30  |  15KB  |  489 lines

  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                      S Y S T E M . I M G _ R E A L                       --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.21 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Img_LLU;             use System.Img_LLU;
  27. with System.Img_Uns;             use System.Img_Uns;
  28. with System.Dependent_Constants; use System.Dependent_Constants;
  29. with System.Powten_Table;        use System.Powten_Table;
  30. with System.Unsigned_Types;      use System.Unsigned_Types;
  31.  
  32. package body System.Img_Real is
  33.  
  34.    Maxdigs : constant := Long_Long_Unsigned'Width - 2;
  35.    --  Maximum decimal digits for type Long_Long_Unsigned. We assume that this
  36.    --  is large enough for the most accurate floating-point type around, which
  37.    --  is probably correct for pretty much all machines we are likely to see.
  38.    --  At worst, if this assumption is false, then we just loose some precision
  39.    --  for high accuracy floating-point, and that's OK, since we only promise
  40.    --  support of the numerics annex accuracy for IEEE machines anyway (and so
  41.    --  far ther is no IEEE machine that would violate this assumption.
  42.    --
  43.    --  The -2 comes from 1 for the sign, and one for the extra digit, since
  44.    --  we need the maximum number of 9's that can be supported, e.g. for the
  45.    --  normal 64 bit case, Long_Long_Integer'Width is 21, since the maximum
  46.    --  value (approx 1.6 * 10**19) has 20 digits.
  47.  
  48.    Unsdigs : constant := Unsigned'Width - 2;
  49.    --  Number of digits that can be converted using type Unsigned
  50.    --  See above for the explanation of the -2.
  51.  
  52.    --------------------------------
  53.    -- Image_Ordinary_Fixed_Point --
  54.    --------------------------------
  55.  
  56.    function Image_Ordinary_Fixed_Point
  57.      (V    : Long_Long_Float;
  58.       S    : access String;
  59.       Aft  : Natural)
  60.       return Natural
  61.    is
  62.       P : Natural := 0;
  63.  
  64.    begin
  65.       Set_Image_Real (V, S.all, P, 2, Aft, 0);
  66.       return P;
  67.    end Image_Ordinary_Fixed_Point;
  68.  
  69.    --------------------------
  70.    -- Image_Floating_Point --
  71.    --------------------------
  72.  
  73.    function Image_Floating_Point
  74.      (V    : Long_Long_Float;
  75.       S    : access String;
  76.       Digs : Natural)
  77.       return Natural
  78.    is
  79.       P : Natural := 0;
  80.  
  81.    begin
  82.       Set_Image_Real (V, S.all, P, 2, Digs - 1, 4);
  83.       return P;
  84.    end Image_Floating_Point;
  85.  
  86.    --------------------
  87.    -- Set_Image_Real --
  88.    --------------------
  89.  
  90.    procedure Set_Image_Real
  91.      (V    : Long_Long_Float;
  92.       S    : out String;
  93.       P    : in out Natural;
  94.       Fore : Natural;
  95.       Aft  : Natural;
  96.       Exp  : Natural)
  97.    is
  98.       NFrac : constant Natural := Natural'Max (Aft, 1);
  99.       Sign  : Character;
  100.       X     : Long_Long_Float;
  101.       X1    : Long_Long_Float;
  102.       X2    : Long_Long_Float;
  103.       Scale : Integer;
  104.       Expon : Integer;
  105.  
  106.       Digs : String (1 .. 2 * Field_Max);
  107.       --  Array used to hold digits of converted integer value. This is a
  108.       --  large enough buffer to accomodate ludicrous values of Fore and Aft.
  109.  
  110.       Ndigs : Natural;
  111.       --  Number of digits stored in Digs (and also subscript of last digit)
  112.  
  113.       procedure Adjust_Scale (S : Natural);
  114.       --  Adjusts the value in X by multiplying or dividing by a power of
  115.       --  ten so that it is in the range 10**(S-1) <= X < 10**S. Includes
  116.       --  adding 0.5 to round the result, readjusting if the rounding causes
  117.       --  the result to wander out of the range. Scale is adjusted to reflect
  118.       --  the power of ten used to divide the result (i.e. one is added to
  119.       --  the scale value for each division by 10.0, or one is subtracted
  120.       --  for each multiplication by 10.0).
  121.  
  122.       procedure Convert_Integer;
  123.       --  Takes the value in X, outputs integer digits into Digs. On return,
  124.       --  Ndigs is set to the number of digits stored. The digits are stored
  125.       --  in Digs (1 .. Ndigs),
  126.  
  127.       procedure Set (C : Character);
  128.       --  Sets character C in output buffer
  129.  
  130.       procedure Set_Blanks_And_Sign (N : Integer);
  131.       --  Sets leading blanks and minus sign if needed. N is the number of
  132.       --  positions to be filled (a minus sign is output even if N is zero
  133.       --  or negative, but for a positive value, if N is non-positive, then
  134.       --  the call has no effect).
  135.  
  136.       procedure Set_Digs (S, E : Natural);
  137.       --  Set digits S through E from Digs buffer. No effect if S > E
  138.  
  139.       procedure Set_Special_Fill (N : Natural);
  140.       --  After outputting +Inf, -Inf or NaN, this routine fills out the
  141.       --  rest of the field with * characters. The argument is the number
  142.       --  of characters output so far (either 3 or 4)
  143.  
  144.       procedure Set_Zeros (N : Integer);
  145.       --  Set N zeros, no effect if N is negative
  146.  
  147.       pragma Inline (Set);
  148.       pragma Inline (Set_Digs);
  149.       pragma Inline (Set_Zeros);
  150.  
  151.       procedure Adjust_Scale (S : Natural) is
  152.          Lo  : Natural;
  153.          Hi  : Natural;
  154.          Mid : Natural;
  155.          XP  : Long_Long_Float;
  156.  
  157.       begin
  158.          --  Cases where scaling up is required
  159.  
  160.          if X < Powten (S - 1) then
  161.  
  162.             --  What we are looking for is a power of ten to multiply X by
  163.             --  so that the result lies within the required range.
  164.  
  165.             loop
  166.                XP := X * Powten (40);
  167.                exit when XP >= Powten (S - 1);
  168.                X := XP;
  169.                Scale := Scale - 40;
  170.             end loop;
  171.  
  172.             --  Here we know that we must mutiply by at least 10**1 and 10**40
  173.             --  takes us too far, so use a binary search to find the right one.
  174.  
  175.             Lo := 1;
  176.             Hi := 40;
  177.  
  178.             loop
  179.                Mid := (Lo + Hi) / 2;
  180.                XP := X * Powten (Mid);
  181.  
  182.                if XP < Powten (S - 1) then
  183.                   Lo := Mid + 1;
  184.  
  185.                elsif XP >= Powten (S) then
  186.                   Hi := Mid - 1;
  187.  
  188.                else
  189.                   X := XP;
  190.                   Scale := Scale - Mid;
  191.                   exit;
  192.                end if;
  193.             end loop;
  194.  
  195.          --  Cases where scaling down is required
  196.  
  197.          elsif X >= Powten (S) then
  198.  
  199.             --  What we are looking for is a power of ten to divide X by
  200.             --  so that the result lies within the required range.
  201.  
  202.             loop
  203.                XP := X / Powten (40);
  204.                exit when XP < Powten (S);
  205.                X := XP;
  206.                Scale := Scale + 40;
  207.             end loop;
  208.  
  209.             --  Here we know that we must divide by at least 10**1 and 10**40
  210.             --  takes us too far, so use a binary search to find the right one.
  211.  
  212.             Lo := 1;
  213.             Hi := 40;
  214.  
  215.             loop
  216.                Mid := (Lo + Hi) / 2;
  217.                XP := X / Powten (Mid);
  218.  
  219.                if XP < Powten (S - 1) then
  220.                   Hi := Mid - 1;
  221.  
  222.                elsif XP >= Powten (S) then
  223.                   Lo := Mid + 1;
  224.  
  225.                else
  226.                   X := XP;
  227.                   Scale := Scale + Mid;
  228.                   exit;
  229.                end if;
  230.             end loop;
  231.  
  232.          --  Here we are already scaled right
  233.  
  234.          else
  235.             null;
  236.          end if;
  237.  
  238.          --  Round, readjusting scale if needed. Note that if a readjustment
  239.          --  occurs, then it is never necessary to round again, because there
  240.          --  is no possibility of such a second rounding causing a change.
  241.  
  242.          X := X + 0.5;
  243.  
  244.          if X > Powten (S) then
  245.             X := X / 10.0;
  246.             Scale := Scale + 1;
  247.          end if;
  248.  
  249.       end Adjust_Scale;
  250.  
  251.       procedure Convert_Integer is
  252.       begin
  253.          --  Use Unsigned routine if possible, since on many machines it will
  254.          --  be significantly more efficient than the Long_Long_Unsigned one.
  255.  
  256.          if X < Powten (Unsdigs) then
  257.             Ndigs := 0;
  258.             Set_Image_Unsigned
  259.               (Unsigned (Long_Long_Float'Truncation (X)),
  260.                Digs, Ndigs);
  261.  
  262.          --  But if we want more digits than fit in Unsigned, we have to use
  263.          --  the Long_Long_Unsigned routine after all.
  264.  
  265.          else
  266.             Ndigs := 0;
  267.             Set_Image_Long_Long_Unsigned
  268.               (Long_Long_Unsigned (Long_Long_Float'Truncation (X)),
  269.                Digs, Ndigs);
  270.          end if;
  271.       end Convert_Integer;
  272.  
  273.       procedure Set (C : Character) is
  274.       begin
  275.          P := P + 1;
  276.          S (P) := C;
  277.       end Set;
  278.  
  279.       procedure Set_Blanks_And_Sign (N : Integer) is
  280.          W : Integer := N;
  281.  
  282.       begin
  283.          if Sign = '-' then
  284.             for J in 1 .. N - 1 loop
  285.                Set (' ');
  286.             end loop;
  287.  
  288.             Set ('-');
  289.  
  290.          else
  291.             for J in 1 .. N loop
  292.                Set (' ');
  293.             end loop;
  294.          end if;
  295.       end Set_Blanks_And_Sign;
  296.  
  297.       procedure Set_Digs (S, E : Natural) is
  298.       begin
  299.          for J in S .. E loop
  300.             Set (Digs (J));
  301.          end loop;
  302.       end Set_Digs;
  303.  
  304.       procedure Set_Special_Fill (N : Natural) is
  305.          F : Natural;
  306.  
  307.       begin
  308.          F := Fore + 1 + Aft - N;
  309.  
  310.          if Exp /= 0 then
  311.             F := F + Exp + 1;
  312.          end if;
  313.  
  314.          for J in 1 .. F loop
  315.             Set ('*');
  316.          end loop;
  317.       end Set_Special_Fill;
  318.  
  319.       procedure Set_Zeros (N : Integer) is
  320.       begin
  321.          for J in 1 .. N loop
  322.             Set ('0');
  323.          end loop;
  324.       end Set_Zeros;
  325.  
  326.    --  Start of processing for Set_Image_Real
  327.  
  328.    begin
  329.       Scale := 0;
  330.       Sign := '+';
  331.  
  332.       --  Positive values
  333.  
  334.       if V > 0.0 then
  335.          X := V;
  336.  
  337.       --  Negative values
  338.  
  339.       elsif V < 0.0 then
  340.          X := -V;
  341.          Sign := '-';
  342.  
  343.       --  Zero values
  344.  
  345.       elsif V = 0.0 then
  346.          Set_Blanks_And_Sign (Fore - 1);
  347.          Set ('0');
  348.          Set ('.');
  349.          Set_Zeros (NFrac);
  350.  
  351.          if Exp /= 0 then
  352.             Set ('E');
  353.             Set ('+');
  354.             Set_Zeros (Exp - 1);
  355.          end if;
  356.  
  357.          return;
  358.  
  359.       --  Only NaN's fail all three of the above tests!
  360.  
  361.       else
  362.          Set ('N');
  363.          Set ('a');
  364.          Set ('N');
  365.          Set_Special_Fill (3);
  366.          return;
  367.       end if;
  368.  
  369.       --  If value is greater than Long_Long_Float'Last it is infinite
  370.  
  371.       if X > Long_Long_Float'Last then
  372.          Set (Sign);
  373.          Set ('I');
  374.          Set ('n');
  375.          Set ('f');
  376.          Set_Special_Fill (4);
  377.  
  378.       --  Case of non-zero value with Exp = 0
  379.  
  380.       elsif Exp = 0 then
  381.  
  382.          --  Multiply by 10 ** NFrac to get an integer value to output
  383.          --  except that if we are already greater than 10**Maxdigs,
  384.          --  or the multiplication would make us larger than that,
  385.          --  then we don't want to do the multiplication after all.
  386.  
  387.          X1 := X;
  388.  
  389.          if X < Powten (Maxdigs) then
  390.             X1 := X * Powten (NFrac);
  391.          end if;
  392.  
  393.          --  If that makes us too large, it means that we have some digits
  394.          --  in the output that are non-significant, and will be output as
  395.          --  zeroes, so in this case we need to scale so that:
  396.  
  397.          --    10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs
  398.  
  399.          if X1 >= Powten (Maxdigs) then
  400.             Adjust_Scale (Maxdigs);
  401.          else
  402.             X := X1;
  403.          end if;
  404.  
  405.          X := X + 0.5;
  406.  
  407.          Convert_Integer;
  408.  
  409.          --  If we had to scale, then we certainly scaled down, i.e. Scale is
  410.          --  the number of insignificant zero digits to be output at the end,
  411.          --  so add them to the resulting integer value.
  412.  
  413.          for J in 1 .. Scale loop
  414.             Ndigs := Ndigs + 1;
  415.             Digs (Ndigs) := '0';
  416.          end loop;
  417.  
  418.          --  If number of available digits is less or equal to NFrac,
  419.          --  then we need an extra zero before the decimal point.
  420.  
  421.          if Ndigs <= NFrac then
  422.             Set_Blanks_And_Sign (Fore - 1);
  423.             Set ('0');
  424.             Set ('.');
  425.             Set_Zeros (NFrac - Ndigs);
  426.             Set_Digs (1, Ndigs);
  427.  
  428.          --  Normal case with some digits before the decimal point
  429.  
  430.          else
  431.             Set_Blanks_And_Sign (Fore - (Ndigs - NFrac));
  432.             Set_Digs (1, Ndigs - NFrac);
  433.             Set ('.');
  434.             Set_Digs (Ndigs - NFrac + 1, Ndigs);
  435.          end if;
  436.  
  437.       --  Case of non-zero value with non-zero Exp value
  438.  
  439.       else
  440.          --  If NFrac is less than Maxdigs, then all the fraction digits are
  441.          --  significant, so we can scale the resulting integer accordingly.
  442.  
  443.          if NFrac < Maxdigs then
  444.             Adjust_Scale (NFrac + 1);
  445.             Convert_Integer;
  446.  
  447.          --  Otherwise, we get the maximum number of digits available
  448.  
  449.          else
  450.             Adjust_Scale (Maxdigs);
  451.             Convert_Integer;
  452.  
  453.             for J in 1 .. NFrac - Maxdigs + 1 loop
  454.                Ndigs := Ndigs + 1;
  455.                Digs (Ndigs) := '0';
  456.                Scale := Scale - 1;
  457.             end loop;
  458.          end if;
  459.  
  460.          Set_Blanks_And_Sign (Fore - 1);
  461.          Set (Digs (1));
  462.          Set ('.');
  463.          Set_Digs (2, Ndigs);
  464.  
  465.          --  The exponent is the scaling factor adjusted for the digits
  466.          --  that we output after the decimal point, since these were
  467.          --  included in the scaled digits that we output.
  468.  
  469.          Expon := Scale + NFrac;
  470.  
  471.          Set ('E');
  472.          Ndigs := 0;
  473.  
  474.          if Expon >= 0 then
  475.             Set ('+');
  476.             Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);
  477.          else
  478.             Set ('-');
  479.             Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);
  480.          end if;
  481.  
  482.          Set_Zeros (Exp - Ndigs - 1);
  483.          Set_Digs (1, Ndigs);
  484.       end if;
  485.  
  486.    end Set_Image_Real;
  487.  
  488. end System.Img_Real;
  489.